;;;    lambda-tube (λ-tube) - A youtube search API and application in scheme.
;;;    Copyright (C) 2008  Abhishek Mishra
;;;
;;;    This program is free software: you can redistribute it and/or modify
;;;    it under the terms of the GNU General Public License as published by
;;;    the Free Software Foundation, either version 3 of the License, or
;;;    (at your option) any later version.

;;;    This program is distributed in the hope that it will be useful,
;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;    GNU General Public License for more details.

;;;    You should have received a copy of the GNU General Public License
;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.


;;;defines all interfaces to the youtube api

(module lt-if mzscheme
  (require (lib "class.ss"))
  (require (lib "string.ss"))
  (require (lib "url.ss" "net"))
  (require (lib "head.ss" "net"))
  (require (lib "pregexp.ss"))
  (require (lib "uri-codec.ss" "net"))
  (require (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0)))
  (require (planet "ssax.ss" ("lizorkin" "ssax.plt" 2 0)))
  (provide video-entry% video-feed% lt-query%)
  
  ;some constants needed later
  (define const-video-url-real-str "http://www.youtube.com/get_video?video_id=~a&t=~a")
  (define const-video-url-fmt-real-str "http://www.youtube.com/get_video?video_id=~a&t=~a&fmt=~a")
  (define const-video-info-url "http://www.youtube.com/get_video_info?&video_id=~a~a&ps=default&eurl=&gl=US&hl=en")
  
  (define const-url-t-param-re (regexp ", \"t\": \"([^\"]+)\""))
  
  (define const-el-type '("&el=embedded" "&el=detailpage" "&el=vevo" ""))
  
  ;some common functions
  (define (last-element l)
    (if (list? l)
        (if (eq? l '())
            #f
            (if (eq? (cdr l) '())
                (car l)
                (last-element (cdr l))))))
  
  (define (get-extn-for-fmt fmt)
    (cond
      ((equal? fmt "6") ".flv")
      ((equal? fmt "13") ".3gp")
      ((equal? fmt "17") ".3gp")
      ((equal? fmt "18") ".mp4")
      ((equal? fmt "22") ".mp4")
      ((equal? fmt "34") ".flv")
      ((equal? fmt "35") ".flv")
      ((equal? fmt "38") ".flv")
      (else ".flv")))
  
  ;video entry class
  (define video-entry% 
    (class object%
      (init-field xml-data)
      
      (field (fmt "35"))
      
      (super-new)
      
      (define/public (get-id)
        (car ((sxpath "atom:id/text()" '[(atom . "atom")]) xml-data)))
      (define/public (get-title)
        (car ((sxpath "atom:title/text()" '[(atom . "atom")]) xml-data)))
      (define/public (get-content)
        (car ((sxpath "atom:content/text()" '[(atom . "atom")]) xml-data)))
      (define/public (get-author-name)
        (car ((sxpath "atom:author/atom:name/text()" '[(atom . "atom")]) xml-data)))
      (define/public (get-url)
        (car ((sxpath "atom:link[@rel='alternate']/@href/text()" '[(atom . "atom")]) xml-data)))
      (define/public (get-thumbnail)
        (cadr ((sxpath "media:group/media:thumbnail/@url/text()" '[(media . "media")]) xml-data)))
      (define/public (get-duration)
        (string->number (car ((sxpath "media:group/yt:duration/@seconds/text()" '[(media . "media") (yt . "yt")]) xml-data))))
      (define/public (get-viewCount)
        (string->number (car ((sxpath "media:group/yt:statistics/@viewCount/text()" '[(media . "media") (yt . "yt")]) xml-data))))
      (define/public (get-favoriteCount)
        (string->number (car ((sxpath "media:group/yt:statistics/@favoriteCount/text()" '[(media . "media") (yt . "yt")]) xml-data))))
      (define/public (get-min-rating)
        (if (eq? ((sxpath "gd:rating" '[(gd . "gd")]) xml-data) '())
            #f
            (string->number (car ((sxpath "gd:rating/@min/text()" '[(gd . "gd")]) xml-data)))))
      (define/public (get-max-rating)
        (if (eq? ((sxpath "gd:rating" '[(gd . "gd")]) xml-data) '())
            #f
            (string->number (car ((sxpath "gd:rating/@max/text()" '[(gd . "gd")]) xml-data)))))
      (define/public (get-num-raters)
        (if (eq? ((sxpath "gd:rating" '[(gd . "gd")]) xml-data) '())
            #f
            (string->number (car ((sxpath "gd:rating/@numRaters/text()" '[(gd . "gd")]) xml-data)))))
      (define/public (get-avg-rating)
        (if (eq? ((sxpath "gd:rating" '[(gd . "gd")]) xml-data) '())
            #f
            (string->number (car ((sxpath "gd:rating/@average/text()" '[(gd . "gd")]) xml-data)))))
      
      (define/public (set-format f)
        (set! fmt f))
      
      (define/public (download-video download-folder update-procedure)
        (let ((vid-info (get-video-info)))
          (if (eq? vid-info #f)
              (update-procedure -1 0 "" "ERROR_NO_VID_INFO")
              (let ((real-url (send vid-info get-url-for-format fmt)))
                (if (eq? real-url #f)
                    (if (equal? fmt "35")
                        (begin
                          (set-format (caar (send vid-info get-video-formats)))
                          (download-video download-folder update-procedure))
                        (begin 
                          (set-format "35")
                          (download-video download-folder update-procedure)))
                    (get-video real-url download-folder update-procedure))))))
      
      (define/public (download-video-in-fmt download-folder update-procedure)
        (download-video download-folder update-procedure))
      
      (define (get-video-info)
        (get-vid-info const-el-type))
      
      ;try to get the vid info page
      ;check if token is there for each el type
      ;return if successful, else try all types till
      ;el-types-list is exhausted - in which case return false.
      (define (get-vid-info el-types-list)
        (if (eq? el-types-list '())
            #f
            (let ((vid-info  
                   (new video-info% 
                        [video-info-alist 
                         (form-urlencoded->alist
                          (form-urlencoded-decode 
                           (get-video-info-str 
                            (format const-video-info-url 
                                    (last-element (regexp-split "/" (get-id)))
                                    (car el-types-list)))))])))
              (if (eq? #f (send vid-info get-token))
                  (get-vid-info (cdr el-types-list))
                  vid-info))))
      
      (define (get-video-info-str video-info-page-url)
        (if (equal? (substring video-info-page-url 0 5) "https")
            #f
            (let ((video-info-page-port (get-impure-port (string->url video-info-page-url))))
              (let ((respose-header-string (purify-port video-info-page-port)))
                (let ((is (open-input-string respose-header-string)))
                  (let ((status-code (string->number (cadr (pregexp-split " " (read-line is))))))
                    (if (eq? status-code 200)
                        (let ((fmt-str (get-fmt-string-from-input-port video-info-page-port)))
                          ;(display fmt-str)
                          fmt-str))))))))
      
      (define (get-fmt-string-from-input-port i-p)
        (let ((s (read-line i-p 'any)))
          (if (eof-object? s)
              #f
              s)))
      
      ;      (define/public (download-video-old download-folder update-procedure)
      ;        (let ((t-param (get-t-parameter (get-url))))
      ;          (if (eq? t-param #f)
      ;              (update-procedure -1 0 "" "ERROR_T_PARAM")
      ;              (let ((real-url (format const-video-url-real-str 
      ;                                      (last-element (regexp-split "/" (get-id)))
      ;                                      t-param)))
      ;                (get-video real-url download-folder update-procedure)))))
      ;      
      ;      (define/public (download-video-old-in-fmt download-folder update-procedure)
      ;        (let ((t-param (get-t-parameter (get-url))))
      ;          (if (eq? t-param #f)
      ;              (update-procedure -1 0 "" "ERROR_T_PARAM")
      ;              (let ((real-url (format const-video-url-fmt-real-str 
      ;                                      (last-element (regexp-split "/" (get-id)))
      ;                                      t-param
      ;                                      fmt)))
      ;                (get-video real-url download-folder update-procedure)))))
      ;      
      ;download exists
      (define/public (video-downloaded? download-folder)
        (file-exists? (get-download-path download-folder)))
      ;      
      ;      (define (get-t-parameter video-webpage-url)
      ;        (if (equal? (substring video-webpage-url 0 5) "https")
      ;            #f
      ;            (let ((video-webpage-port (get-impure-port (string->url video-webpage-url))))
      ;              (let ((respose-header-string (purify-port video-webpage-port)))
      ;                (let ((is (open-input-string respose-header-string)))
      ;                  (let ((status-code (string->number (cadr (pregexp-split " " (read-line is))))))
      ;                    (if (or (= status-code 302) (= status-code 303))
      ;                        (begin
      ;                          (get-t-parameter (extract-field "Location" respose-header-string)))
      ;                        (if (eq? status-code 200)
      ;                            (let ((t-param (get-t-from-input-port video-webpage-port)))
      ;                              t-param)))))))))
      ;      
      ;      (define (get-t-from-input-port i-p)
      ;        (let ((s (read-line i-p 'any)))
      ;          (if (eof-object? s)
      ;              #f
      ;              (let ((match-str (regexp-match const-url-t-param-re s)))
      ;                (if (eq? match-str #f)
      ;                    (get-t-from-input-port i-p)
      ;                    (cadr match-str))))))
      
      ;utility method to download the video as file on disk.
      (define (get-video video-url target-folder update-proc)
        (let* ((filename (get-download-path target-folder)))
          (if (file-exists? filename)
              (begin
                (update-proc 1 1 filename #f)
                filename )
              (let ((video-port (get-impure-port (string->url video-url))))
                (let ((respose-header-string (purify-port video-port)))
                  (let* ((is (open-input-string respose-header-string))
                         (status-code (string->number (cadr (pregexp-split " " (read-line is))))))
                    (cond
                      ((or (= status-code 302) (= status-code 303))
                       (begin
                         (get-video (extract-field "Location" respose-header-string) target-folder update-proc)))
                      ((eq? status-code 200)
                       (let ((file-port (open-output-file filename)))
                         (let ((content-length (string->number (extract-field "Content-Length" respose-header-string))))
                           (pure-port->file-port video-port file-port update-proc content-length 0 filename))
                         filename))
                      (else (update-proc -1 0 filename "ERROR_HTTP_DOWNLOAD"))))))
              )))
      
      
      (define (pure-port->file-port pure-port file-port update-proc content-len done filename)
        (let ((in (read-bytes 10240 pure-port)))
          (if (eof-object? in) 
              (close-output-port file-port)
              (begin
                (write-bytes in file-port)
                (update-proc (+ done (bytes-length in)) content-len filename #f)
                (pure-port->file-port pure-port file-port update-proc content-len (+ done (bytes-length in)) filename)))))
      
      (define/public (get-download-path target-folder)
        (cond ((eq? (system-type) 'windows)
               (let ((valid-title (regexp-replace* "([\\\\/:\\*\\?\\\"<>|])" (get-title) "%%")))
                 (build-path target-folder (string-append (last-element (regexp-split "/" (get-id))) "-" valid-title (get-extn-for-fmt fmt)))))
              ((eq? (system-type) 'unix)
               (let ((valid-title (regexp-replace* "([/\"])" (get-title) "%%")))
                 (build-path target-folder (string-append (last-element (regexp-split "/" (get-id))) "-" valid-title (get-extn-for-fmt fmt)))))))
      
      ;gets a header from a url
      (define (get-header request-url header-param)
        (let ((i-port (get-impure-port (string->url request-url))))
          (letrec ((l1 (lambda (i-p)
                         (let ((s (read-line i-p 'any)))
                           (if (eof-object? s)
                               #f
                               (let ((match-str (regexp-match (string-append header-param ": (.*)") s)))
                                 (if (eq? match-str #f)
                                     (l1 i-p)
                                     (cadr match-str)))))))) 
            (l1 i-port))))
      
      
      ))
  
  ;youtube video feed class
  (define video-feed%
    (class object%
      (public get-video-feed-author get-video-feed-id get-videos)
      
      (init-field url)
      (init-field xml-data)
      
      (super-new)
      
      (define (get-video-feed-author)
        (car ((sxpath "atom:feed/atom:author/atom:name/text()" '[(atom . "atom")]) xml-data))
        )
      
      (define (get-video-feed-id)
        (car ((sxpath "atom:feed/atom:id/text()" '[(atom . "atom")]) xml-data))
        )
      
      (define (get-videos)
        (let ((entries ((sxpath "atom:feed/atom:entry" '[(atom . "atom")]) xml-data)))
          ;(write entries)
          (create-video-entries entries ())
          )
        )
      (define (create-video-entries entries video-entries)
        (if (eq? entries ())
            video-entries 
            (begin
              (let ((current-entry (car entries)))
                ;(write ((sxpath "atom:id" '[(atom . "atom")]) current-entry))
                (create-video-entries (cdr entries) (cons (new video-entry% [xml-data current-entry]) video-entries))))))
      
      (define/public (get-start-index)
        (car ((sxpath "atom:feed/openSearch:startIndex/text()" '[(atom . "atom") (openSearch . "openSearch")]) xml-data)))
      (define/public (get-items-per-page)
        (car ((sxpath "atom:feed/openSearch:itemsPerPage/text()" '[(atom . "atom") (openSearch . "openSearch")]) xml-data)))
      (define/public (get-total-results)
        (car ((sxpath "atom:feed/openSearch:totalResults/text()" '[(atom . "atom") (openSearch . "openSearch")]) xml-data)))
      ))
  
  ;youtube query class
  ;for building a full query and executing it
  ;then setting a feed.
  (define lt-query%
    (class object%
      (public run-query)
      
      ;initialization fields
      (init-field query-string)
      (init-field (url "http://gdata.youtube.com/feeds/api/videos"))
      (init-field (order-by "relevance"))
      (init-field (include-racy? "exclude"))
      (init-field (start-index 1))
      (init-field (max-results 5))
      
      
      (super-new)
      
      ;local vars
      
      ;query param names
      (define query-str-param "vq")
      (define order-by-param "orderby")
      (define start-index-param "start-index")
      (define max-results-param "max-results")
      (define author-param "author")
      (define alt-param "alt")
      (define format-param "format")
      (define lr-param "lr")
      (define racy-param "racy")
      (define restriction-param "restriction")
      (define time-param "time")
      
      (define feed-xml "")
      
      ;methods
      ;create the query url
      (define (create-query-url)
        (string->url 
         (string-append 
          url 
          "?" 
          query-str-param 
          "=" 
          query-string
          "&"
          order-by-param
          "="
          order-by
          "&"
          racy-param
          "="
          include-racy?
          "&"
          start-index-param
          "="
          (number->string start-index)
          "&"
          max-results-param
          "="
          (number->string max-results))))
      
      ;;run the query
      (define (run-query)
        (call/input-url 
         (create-query-url)
         get-pure-port 
         build-feed-from-pure-port)
        )
      
      ;build feed
      (define (build-feed-from-pure-port input-port)
        (set! feed-xml (ssax:xml->sxml input-port '((atom . "http://www.w3.org/2005/Atom") 
                                                    (media . "http://search.yahoo.com/mrss/") 
                                                    (openSearch . "http://a9.com/-/spec/opensearchrss/1.0/")
                                                    (yt . "http://gdata.youtube.com/schemas/2007")
                                                    (gd . "http://schemas.google.com/g/2005"))))
        ;(display (url->string (create-query-url)))
        ;(newline)
        ;(display feed-xml)
        (new video-feed% [url (url->string (create-query-url))] [xml-data feed-xml])
        )
      )
    )
  
  ;get all parameter values in an alist
  (define (get-all-values-alist key alist)
    (get-all-vals-alist key alist '()))
  
  (define (get-all-vals-alist key alist current-vals)
    (if (eq? alist '())
        current-vals
        (if (eq? (caar alist) key)
            (get-all-vals-alist key (cdr alist) (append current-vals (list (cdar alist))))
            (get-all-vals-alist key (cdr alist) current-vals))))
  
  ;(define test-list (list (list 'a 'val0) (list 'b 'val1) (list 'a 'val2)))
  ;(display (get-all-values-alist 'a test-list))
  
  ;youtube video info class
  ;The info is extracted from the alist of
  ;the video info parameters
  (define video-info%
    (class object%
      ;(public get-video-formats)
      
      (init-field video-info-alist)
      
      (super-new)
;      (display video-info-alist)
;      (newline)
;      (display (is-video-available-for-download?))
;      (newline)
;      (display (get-all-values-alist 'fmt_list video-info-alist))
;      (newline)
;      (display (get-status))
;      (newline)
;      (display (get-token))
;      (newline)
;      (display (get-video-formats))
;      (newline)
      
      (define/public (get-param-value param-name)
        (let ((param-list (assv param-name video-info-alist)))
          (if (or (eq? param-list '()) (eq? param-list #f))
              #f
              (cdr param-list))))
      
      (define/public (get-status)
        (get-param-value 'status))
      
      (define/public (get-errorcode)
        (get-param-value 'errorcode))
      
      (define/public (get-reason)
        (get-param-value 'reason))
      
      (define/public (get-token)
        (get-param-value 'token))
      
      (define/public (is-video-available-for-download?)
        (let ((format-list (get-all-values-alist 'fmt_list video-info-alist)))
          (if (eq? format-list '())
              #f
              #t)))
      
      (define/public (get-video-formats)
        (if (is-video-available-for-download?)
            (let ((format-list (regexp-split "," (car (get-all-values-alist 'fmt_list video-info-alist)))))
              (map (lambda (x) (regexp-split "/" x)) format-list))
            #f))
      
      (define/public (get-format-by-name fmts fmt)
        (if (eq? fmts '())
            #f
            (if (eq? fmt (caar fmts))
                (car fmts)
                (get-format-by-name (cdr fmts) fmt))))
      
      (define/public (get-itags) 
        (get-all-values-alist 'itag video-info-alist))
      
      (define/public (get-url-for-format fmt-name) 
        (get-url-for-fmt (get-itags) fmt-name))
      
      (define (get-url-for-fmt itags fmt-name)
        (if (eq? itags '())
            #f
            (let ((itag (car itags)))
              (let ((urlstr (cadr (regexp-split "," itag))))
                (substring urlstr 4 (string-length urlstr))))
            ))
      ))
  )
